home *** CD-ROM | disk | FTP | other *** search
/ Inter.Net 55-1 / Inter.Net 55-1.iso / CBuilder / Setup / BCB / data.z / comobj.int < prev    next >
Encoding:
Text File  |  1998-02-09  |  10.0 KB  |  284 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Runtime Library                          }
  5. {                                                       }
  6. {       Copyright (C) 1998 Borland International        }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit ComObj;
  11.  
  12. interface
  13.  
  14. uses Windows, ActiveX, SysUtils;
  15.  
  16. type
  17. { Forward declarations }
  18.  
  19.   TComObjectFactory = class;
  20.  
  21. { COM server abstract base class }
  22.  
  23.   TComServerObject = class(TObject)
  24.   protected
  25.     function CountObject(Created: Boolean): Integer; virtual; abstract;
  26.     function CountFactory(Created: Boolean): Integer; virtual; abstract;
  27.     function GetHelpFileName: string; virtual; abstract;
  28.     function GetServerFileName: string; virtual; abstract;
  29.     function GetServerKey: string; virtual; abstract;
  30.     function GetServerName: string; virtual; abstract;
  31.     function GetTypeLib: ITypeLib; virtual; abstract;
  32.   public
  33.     property HelpFileName: string;
  34.     property ServerFileName: string;
  35.     property ServerKey: string;
  36.     property ServerName: string;
  37.     property TypeLib: ITypeLib;
  38.   end;
  39.  
  40. { COM class manager }
  41.  
  42.   TFactoryProc = procedure(Factory: TComObjectFactory) of object;
  43.  
  44.   TComClassManager = class(TObject)
  45.   public
  46.     procedure ForEachFactory(ComServer: TComServerObject;
  47.       FactoryProc: TFactoryProc);
  48.     function GetFactoryFromClass(ComClass: TClass): TComObjectFactory;
  49.     function GetFactoryFromClassID(const ClassID: TGUID): TComObjectFactory;
  50.   end;
  51.  
  52. { COM object }
  53.  
  54.   TComObject = class(TObject, IUnknown, ISupportErrorInfo)
  55.   protected
  56.     { IUnknown }
  57.     function IUnknown.QueryInterface = ObjQueryInterface;
  58.     function IUnknown._AddRef = ObjAddRef;
  59.     function IUnknown._Release = ObjRelease;
  60.     { IUnknown methods for other interfaces }
  61.     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  62.     function _AddRef: Integer; stdcall;
  63.     function _Release: Integer; stdcall;
  64.     { ISupportErrorInfo }
  65.     function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall;
  66.   public
  67.     constructor Create;
  68.     constructor CreateAggregated(const Controller: IUnknown);
  69.     constructor CreateFromFactory(Factory: TComObjectFactory;
  70.       const Controller: IUnknown);
  71.     destructor Destroy; override;
  72.     procedure Initialize; virtual;
  73.     function ObjAddRef: Integer; virtual; stdcall;
  74.     function ObjQueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
  75.     function ObjRelease: Integer; virtual; stdcall;
  76.     function SafeCallException(ExceptObject: TObject;
  77.       ExceptAddr: Pointer): HResult; override;
  78.     property Controller: IUnknown;
  79.     property Factory: TComObjectFactory;
  80.     property RefCount: Integer;
  81.   end;
  82.  
  83. { COM class }
  84.  
  85.   TComClass = class of TComObject;
  86.  
  87. { Instancing mode for COM classes }
  88.  
  89.   TClassInstancing = (ciInternal, ciSingleInstance, ciMultiInstance);
  90.  
  91. { COM object factory }
  92.  
  93.   TComObjectFactory = class(TObject, IUnknown, IClassFactory, IClassFactory2)
  94.   protected
  95.     function GetProgID: string; virtual;
  96.     function GetLicenseString: WideString; virtual;
  97.     function HasMachineLicense: Boolean; virtual;
  98.     function ValidateUserLicense(const LicStr: WideString): Boolean; virtual;
  99.     { IUnknown }
  100.     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  101.     function _AddRef: Integer; stdcall;
  102.     function _Release: Integer; stdcall;
  103.     { IClassFactory }
  104.     function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
  105.       out Obj): HResult; stdcall;
  106.     function LockServer(fLock: BOOL): HResult; stdcall;
  107.     { IClassFactory2 }
  108.     function GetLicInfo(var licInfo: TLicInfo): HResult; stdcall;
  109.     function RequestLicKey(dwResrved: Longint; out bstrKey: WideString): HResult; stdcall;
  110.     function CreateInstanceLic(const unkOuter: IUnknown; const unkReserved: IUnknown;
  111.       const iid: TIID; const bstrKey: WideString; out vObject): HResult; stdcall;
  112.   public
  113.     constructor Create(ComServer: TComServerObject; ComClass: TComClass;
  114.       const ClassID: TGUID; const ClassName, Description: string;
  115.       Instancing: TClassInstancing);
  116.     destructor Destroy; override;
  117.     function CreateComObject(const Controller: IUnknown): TComObject; virtual;
  118.     procedure RegisterClassObject;
  119.     procedure UpdateRegistry(Register: Boolean); virtual;
  120.     property ClassID: TGUID;
  121.     property ClassName: string;
  122.     property ComClass: TClass;
  123.     property ComServer: TComServerObject;
  124.     property Description: string;
  125.     property ErrorIID: TGUID;
  126.     property LicString: WideString;
  127.     property ProgID: string;
  128.     property Instancing: TClassInstancing;
  129.     property ShowErrors: Boolean;
  130.     property SupportsLicensing: Boolean;
  131.   end;
  132.  
  133. { COM object with type information }
  134.  
  135.   TTypedComObject = class(TComObject, IProvideClassInfo)
  136.   protected
  137.     { IProvideClassInfo }
  138.     function GetClassInfo(out TypeInfo: ITypeInfo): HResult; stdcall;
  139.   end;
  140.  
  141.   TTypedComClass = class of TTypedComObject;
  142.  
  143.   TTypedComObjectFactory = class(TComObjectFactory)
  144.   public
  145.     constructor Create(ComServer: TComServerObject;
  146.       TypedComClass: TTypedComClass; const ClassID: TGUID;
  147.       Instancing: TClassInstancing);
  148.     function GetInterfaceTypeInfo(TypeFlags: Integer): ITypeInfo;
  149.     procedure UpdateRegistry(Register: Boolean); override;
  150.     property ClassInfo: ITypeInfo;
  151.   end;
  152.  
  153. { OLE Automation object }
  154.  
  155.   TAutoObject = class(TTypedComObject, IDispatch)
  156.   protected
  157.     { IDispatch }
  158.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  159.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall;
  160.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtual; stdcall;
  161.     function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall;
  162.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  163.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; stdcall;
  164.   end;
  165.  
  166. { OLE Automation class }
  167.  
  168.   TAutoClass = class of TAutoObject;
  169.  
  170. { OLE Automation object factory }
  171.  
  172.   TAutoObjectFactory = class(TTypedComObjectFactory)
  173.   public
  174.     constructor Create(ComServer: TComServerObject; AutoClass: TAutoClass;
  175.       const ClassID: TGUID; Instancing: TClassInstancing);
  176.     function GetIntfEntry(Guid: TGUID): PInterfaceEntry; virtual;
  177.     property DispIntfEntry: PInterfaceEntry;
  178.     property DispTypeInfo: ITypeInfo;
  179.   end;
  180.  
  181.   TAutoIntfObject = class(TInterfacedObject, IDispatch, ISupportErrorInfo)
  182.   protected
  183.     { IDispatch }
  184.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  185.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  186.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  187.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  188.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  189.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  190.     { ISupportErrorInfo }
  191.     function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall;
  192.   public
  193.     constructor Create(const TypeLib: ITypeLib; const DispIntf: TGUID);
  194.     function SafeCallException(ExceptObject: TObject;
  195.       ExceptAddr: Pointer): HResult; override;
  196.     property DispIntfEntry: PInterfaceEntry;
  197.     property DispTypeInfo: ITypeInfo;
  198.     property DispIID: TGUID;
  199.   end;
  200.  
  201. { OLE exception classes }
  202.  
  203.   EOleError = class(Exception);
  204.  
  205.   EOleSysError = class(EOleError)
  206.   public
  207.     constructor Create(const Message: string; ErrorCode: Integer;
  208.       HelpContext: Integer);
  209.     property ErrorCode: Integer;
  210.   end;
  211.  
  212.   EOleException = class(EOleSysError)
  213.   public
  214.     constructor Create(const Message: string; ErrorCode: Integer;
  215.       const Source, HelpFile: string; HelpContext: Integer);
  216.     property HelpFile: string;
  217.     property Source: string;
  218.   end;
  219.  
  220. type
  221.   { Dispatch call descriptor }
  222.  
  223.   PCallDesc = ^TCallDesc;
  224.   TCallDesc = packed record
  225.     CallType: Byte;
  226.     ArgCount: Byte;
  227.     NamedArgCount: Byte;
  228.     ArgTypes: array[0..255] of Byte;
  229.   end;
  230.  
  231.   PDispDesc = ^TDispDesc;
  232.   TDispDesc = packed record
  233.     DispID: Integer;
  234.     ResType: Byte;
  235.     CallDesc: TCallDesc;
  236.   end;
  237.  
  238. procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc;
  239.   DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
  240. procedure DispatchInvokeError(Status: Integer; const ExcepInfo: TExcepInfo);
  241.  
  242. function HandleSafeCallException(ExceptObject: TObject;
  243.   ExceptAddr: Pointer; const ErrorIID: TGUID; const ProgID,
  244.   HelpFileName: WideString): HResult;
  245.  
  246. function CreateComObject(const ClassID: TGUID): IUnknown;
  247. function CreateRemoteComObject(const MachineName: WideString; const ClassID: TGUID): IUnknown;
  248. function CreateOleObject(const ClassName: string): IDispatch;
  249. function GetActiveOleObject(const ClassName: string): IDispatch;
  250.  
  251. procedure OleError(ErrorCode: HResult);
  252. procedure OleCheck(Result: HResult);
  253.  
  254. function StringToGUID(const S: string): TGUID;
  255. function GUIDToString(const ClassID: TGUID): string;
  256.  
  257. function ProgIDToClassID(const ProgID: string): TGUID;
  258. function ClassIDToProgID(const ClassID: TGUID): string;
  259.  
  260. procedure CreateRegKey(const Key, ValueName, Value: string);
  261. procedure DeleteRegKey(const Key: string);
  262.  
  263. function StringToLPOLESTR(const Source: string): POleStr;
  264.  
  265. procedure RegisterComServer(const DLLName: string);
  266.  
  267. type
  268.   TCoCreateInstanceExProc = function (const clsid: TCLSID;
  269.     unkOuter: IUnknown; dwClsCtx: Longint; ServerInfo: PCoServerInfo;
  270.     dwCount: Longint; rgmqResults: PMultiQIArray): HResult stdcall;
  271.  
  272. var
  273.   CoCreateInstanceEx: TCoCreateInstanceExProc = nil;
  274.   {$EXTERNALSYM CoCreateInstanceEx}
  275.  
  276. procedure ReadPropFromBag(PropBag: IPropertyBag; ErrorLog: IErrorLog;
  277.   const Name: string; var Value: Variant);
  278. procedure PutPropInBag(PropBag: IPropertyBag; const Name: string;
  279.   const Value: Variant);
  280.  
  281. function ComClassManager: TComClassManager;
  282.  
  283. implementation
  284.